home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / import-export / ie-utils.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  3.8 KB  |  122 lines  |  [TEXT/CCL2]
  1.  
  2. ;;; This file contains utilities, globals, and macros used by the
  3. ;;; import-export system.
  4.  
  5. (define *new-exports-found?* '#f)  ; used by the fixpoint iteration
  6.  
  7. ;;; A group is a collection of related symbols.  It is represented
  8. ;;; by a list of (name,def) pairs.  The first element is the head
  9. ;;; of the group; the group is entered in the export table under the
  10. ;;; name of the head only.  Groups for vars and synonyms have only the
  11. ;;; head.  Data types and classes have the constructors or methods in
  12. ;;; the tail of the group.
  13.  
  14. (define (group-name x)  ; name of the head
  15.   (tuple-2-1 (car x)))
  16.  
  17. (define (group-definition x) ; definition of the head
  18.   (tuple-2-2 (car x)))
  19.  
  20. ;;; The name & entry are the head of the group.  Others is a list of
  21. ;;; name - definition pairs.
  22. (define (make-group name entry . others)
  23.   (if (null? others)
  24.       (list (cons name entry))
  25.       (cons (cons name entry) (car others))))
  26.  
  27. (define (hidden-constructors? group)
  28.   (null? (cdr group)))
  29.  
  30. (define (strip-constructors group)
  31.   (list (car group)))
  32.  
  33. ;;; rename-group applies the current renaming  to every
  34. ;;;  name in a group.  When uses, a renaming is marked to allow unused
  35. ;;;  renamings to be detected.
  36.  
  37. (define (rename-group g renamings)
  38.   (if (null? renamings)
  39.       g
  40.       (map (lambda (n-d)
  41.          (let* ((def (tuple-2-2 n-d))
  42.             (keep-name? (or (con? def) (var? def)))
  43.             (n (tuple-2-1 n-d))
  44.             (name (if keep-name? n (add-con-prefix/symbol n)))
  45.             (renaming (locate-renaming name renamings)))
  46.            (cond (renaming
  47.               (let ((new-name
  48.                  (if keep-name?
  49.                  (renaming-to renaming)
  50.                  (remove-con-prefix/symbol
  51.                    (renaming-to renaming)))))
  52.             (when (and (def-core? def)
  53.                    (not (eq? (def-name def) new-name)))
  54.                 (signal-prelude-renaming def new-name)
  55.                 (setf new-name (def-name def)))
  56.             (setf (renaming-referenced? renaming) '#t)
  57.             (tuple new-name def)))
  58.              (else n-d))))
  59.        g)))
  60.  
  61. (define (locate-renaming name renamings)
  62.   (if (null? renamings)
  63.       '#f
  64.       (if (eq? name (renaming-from (car renamings)))
  65.       (car renamings)
  66.       (locate-renaming name (cdr renamings)))))
  67.  
  68. (define (gather-algdata-group name def)
  69.   (cons (tuple name def)
  70.     (gather-group (algdata-constrs def))))
  71.  
  72. (define (gather-class-group name def)
  73.   (cons (tuple name def)
  74.     (gather-group (class-method-vars def))))
  75.  
  76. (define (gather-group defs)
  77.   (if (null? defs)
  78.       '()
  79.       (let ((local-name (local-name (car defs))))
  80.     (if (eq? local-name '#f)
  81.         '()
  82.         (cons (tuple local-name (car defs))
  83.           (gather-group (cdr defs)))))))
  84.  
  85. ;;; These deal with `hiding' lists.
  86.  
  87. ;;; Note: as per the new report, no need to worry about anything but the
  88. ;;; group head and the entity name since only var, Class(..),Alg(..) allowed
  89.  
  90. (define (in-hiding-list? group hiding)
  91.   (cond ((null? hiding)
  92.      '#f)
  93.     ((eq? (entity-name (car hiding)) (group-name group))
  94.      '#t)
  95.     (else (in-hiding-list? group (cdr hiding)))))
  96.  
  97. (define (remove-entity group hiding)
  98.   (cond ((eq? (entity-name (car hiding)) (group-name group))
  99.      (cdr hiding))
  100.     (else (cons (car hiding) (remove-entity group (cdr hiding))))))
  101.  
  102. ;;; This moves fixity information to the local symbols.  This must be
  103. ;;; called after local symbols are installed but before imported
  104. ;;; symbols arrive.
  105.  
  106. (define (attach-fixities)
  107.   (dolist (fixity-decl (module-fixities *module*))
  108.     (let ((fixity (fixity-decl-fixity fixity-decl)))
  109.       (dolist (op (fixity-decl-names fixity-decl))
  110.         (let ((def (resolve-toplevel-name op)))
  111.       (cond ((or (eq? def '#f) (not (eq? *module-name* (def-module def))))
  112.          ;;; ***This is WRONG!  Inner fixities may be found.
  113.          (signal-non-local-fixity op))
  114.         ((var? def)
  115.          (setf (var-fixity def) fixity)
  116.          (setf (table-entry *fixity-table* op) fixity))
  117.         ((con? def)
  118.          (setf (con-fixity def) fixity)
  119.          (setf (table-entry *fixity-table* op) fixity))
  120.         (else (signal-fixity-not-var/con op))))))))
  121.  
  122.